home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / tclmotif.1 / tclmotif / tm.1.2 / src / tmSend.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-03  |  32.8 KB  |  1,211 lines
  1. /* 
  2.  * tmSend.c --
  3.  *
  4.  *    This file provides procedures that implement the "send"
  5.  *    command, allowing commands to be passed from interpreter
  6.  *    to interpreter.
  7.  * Status -
  8.  *    being developed
  9.  *
  10.  * Copyright 1993 Jan Newmarch, University of Canberra
  11.  * Copyright 1989-1992 Regents of the University of California
  12.  * Permission to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose and without
  14.  * fee is hereby granted, provided that the above copyright
  15.  * notice appear in all copies.  The University of California
  16.  * makes no representations about the suitability of this
  17.  * software for any purpose.  It is provided "as is" without
  18.  * express or implied warranty.
  19.  */
  20.  
  21. #ifndef lint
  22. static char rcsid[] = "$Header$";
  23. #endif
  24.  
  25. #include <Xm/Label.h>
  26. #include "tmFuncs.h"
  27.  
  28. /* 
  29.  * The following structure is used to keep track of the
  30.  * interpreters registered by this process.
  31.  */
  32.  
  33. typedef struct RegisteredInterp {
  34.     char *name;            /* Interpreter's name (malloc-ed). */
  35.     Tcl_Interp *interp;        /* Interpreter associated with
  36.                  * name. */
  37.     Tm_Display *dispPtr;    /* Display info associated with name. */
  38.     struct RegisteredInterp *nextPtr;
  39.                 /* Next in list of names associated
  40.                  * with interps in this process.
  41.                  * NULL means end of list. */
  42. } RegisteredInterp;
  43.  
  44. static RegisteredInterp *registry = NULL;
  45.                 /* List of all interpreters
  46.                  * registered by this process. */
  47.  
  48. /*
  49.  * When a result is being awaited from a sent command, one of
  50.  * the following structures is present on a list of all outstanding
  51.  * sent commands.  The information in the structure is used to
  52.  * process the result when it arrives.  You're probably wondering
  53.  * how there could ever be multiple outstanding sent commands.
  54.  * This could happen if interpreters invoke each other recursively.
  55.  * It's unlikely, but possible.
  56.  */
  57.  
  58. typedef struct PendingCommand {
  59.     int serial;            /* Serial number expected in
  60.                  * result. */
  61.     char *target;        /* Name of interpreter command is
  62.                  * being sent to. */
  63.     Tcl_Interp *interp;        /* Interpreter from which the send
  64.                  * was invoked. */
  65.     int code;            /* Tcl return code for command
  66.                  * will be stored here. */
  67.     char *result;        /* String result for command (malloc'ed).
  68.                  * NULL means command still pending. */
  69.     Boolean timedOut;        /* True means timeout proc triggered
  70.                  * false means it hasn't */
  71.     struct PendingCommand *nextPtr;
  72.                 /* Next in list of all outstanding
  73.                  * commands.  NULL means end of
  74.                  * list. */
  75. } PendingCommand;
  76.  
  77. static PendingCommand *pendingCommands = NULL;
  78.                 /* List of all commands currently
  79.                  * being waited for. */
  80.  
  81. /*
  82.  * The information below is used for communication between
  83.  * processes during "send" commands.  Each process keeps a
  84.  * private window, never even mapped, with one property,
  85.  * "Comm".  When a command is sent to an interpreter, the
  86.  * command is appended to the comm property of the communication
  87.  * window associated with the interp's process.  Similarly, when a
  88.  * result is returned from a sent command, it is also appended
  89.  * to the comm property.  In each case, the property information
  90.  * is in the form of an ASCII string.  The exact syntaxes are:
  91.  *
  92.  * Command:
  93.  *    'C' space window space serial space interpName '|' command '\0'
  94.  * The 'C' character indicates that this is a command and not
  95.  * a response.  Window is the hex identifier for the comm
  96.  * window on which to append the response.  Serial is a hex
  97.  * integer containing an identifying number assigned by the
  98.  * sender;  it may be used by the sender to sort out concurrent
  99.  * responses.  InterpName is the ASCII name of the desired
  100.  * interpreter, which must not contain any vertical bar characters
  101.  * The interpreter name is delimited by a vertical bar (this
  102.  * allows the name to include blanks), and is followed by
  103.  * the command to execute.  The command is terminated by a
  104.  * NULL character.
  105.  *
  106.  * Response:
  107.  *    'R' space serial space code space result '\0'
  108.  * The 'R' character indicates that this is a response.  Serial
  109.  * gives the identifier for the command (same value as in the
  110.  * command message).  The code field is a decimal integer giving
  111.  * the Tcl return code from the command, and result is the string
  112.  * result.  The result is terminated by a NULL character.
  113.  *
  114.  * The register of interpreters is kept in a property
  115.  * "InterpRegistry" on the root window of the display.  It is
  116.  * organized as a series of zero or more concatenated strings
  117.  * (in no particular order), each of the form
  118.  *     window space name '\0'
  119.  * where "window" is the hex id of the comm. window to use to talk
  120.  * to an interpreter named "name".
  121.  */
  122.  
  123. /*
  124.  * Maximum size property that can be read at one time by
  125.  * this module:
  126.  */
  127.  
  128. #define MAX_PROP_WORDS 100000
  129.  
  130. /*
  131.  * Forward declarations for procedures defined later in this file:
  132.  */
  133.  
  134. static int    AppendErrorProc _ANSI_ARGS_((Display *display,
  135.             XErrorEvent *errorPtr));
  136. static void    AppendPropCarefully _ANSI_ARGS_((Display *display,
  137.             Window window, Atom property, char *value,
  138.             PendingCommand *pendingPtr));
  139. static void    DeleteProc _ANSI_ARGS_((ClientData clientData));
  140. static Window    LookupName _ANSI_ARGS_((Tm_Display *dispPtr, char *name,
  141.             int delete));
  142. static void    SendEventProc _ANSI_ARGS_((Widget w, XtPointer clientData,
  143.             XEvent *eventPtr, Boolean *continue_dispatch));
  144. static int    SendInit _ANSI_ARGS_((Tcl_Interp *interp, Tm_Display *dispPtr));
  145. /*
  146. static Bool    SendRestrictProc _ANSI_ARGS_((Display *display,
  147.             XEvent *eventPtr, char *arg));
  148. */
  149. static void    TimeoutProc _ANSI_ARGS_((XtPointer clientData, 
  150.             XtIntervalId *id));
  151.  
  152. static int
  153. NoOpProc(display, event)
  154.     Display *display;
  155.     XErrorEvent *event;
  156. {
  157. }
  158.  
  159. /*
  160.  *--------------------------------------------------------------
  161.  *
  162.  * Tm_RegisterInterp --
  163.  *
  164.  *    This procedure is called to associate an ASCII name
  165.  *    with an interpreter.  Tm_InitSend must previously
  166.  *    have been called to set up communication channels
  167.  *    and specify a display.
  168.  *
  169.  * Results:
  170.  *    Zero is returned if the name was registered successfully.
  171.  *    Non-zero means the name was already in use.
  172.  *
  173.  * Side effects:
  174.  *    Registration info is saved, thereby allowing the
  175.  *    "send" command to be used later to invoke commands
  176.  *    in the interpreter.  The registration will be removed
  177.  *    automatically when the interpreter is deleted.
  178.  *
  179.  *--------------------------------------------------------------
  180.  */
  181.  
  182. int
  183. Tm_RegisterInterp(interp, name, dispPtr)
  184.     Tcl_Interp *interp;        /* Interpreter associated with name. */
  185.     char *name;            /* The name that will be used to
  186.                  * refer to the interpreter in later
  187.                  * "send" commands.  Must be globally
  188.                  * unique. */
  189.     Tm_Display *dispPtr;        /* Token for window associated with
  190.                  * interp;  used to identify display
  191.                  * for communication.  */
  192. {
  193. #define TCL_MAX_NAME_LENGTH 1000
  194.     char propInfo[TCL_MAX_NAME_LENGTH + 20];
  195.     register RegisteredInterp *riPtr;
  196.     Window w;
  197.  
  198.     if (strchr(name, '|') != NULL) {
  199.     interp->result =
  200.         "interpreter name cannot contain '|' character";
  201.     return TCL_ERROR;
  202.     }
  203.  
  204.     if (dispPtr->commWidget == NULL) {
  205.     int result;
  206.  
  207.     result = SendInit(interp, dispPtr);
  208.     if (result != TCL_OK) {
  209.         return result;
  210.     }
  211.     }
  212.  
  213.     /*
  214.      * Make sure the name is unique, and append info about it to
  215.      * the registry property.  It's important to lock the server
  216.      * here to prevent conflicting changes to the registry property.
  217.      */
  218.  
  219. /*
  220.     XGrabServer(dispPtr->display);
  221. */
  222.     w = LookupName(dispPtr, name, 0);
  223.     if (w != (Window) 0) {
  224.     Status status;
  225.     int dummyInt;
  226.     unsigned int dummyUns;
  227.     Window dummyWin;
  228.  
  229.     /*
  230.      * The name is currently registered.  See if the commWidget
  231.      * associated with the name exists.  If not, or if the commWidget
  232.      * is *our* commWidget, then just unregister the old name (this
  233.      * could happen if an application dies without cleaning up the
  234.      * registry).
  235.      */
  236.  
  237.         XSetErrorHandler(NoOpProc);
  238.     status = XGetGeometry(dispPtr->display, w, &dummyWin, &dummyInt,
  239.         &dummyInt, &dummyUns, &dummyUns, &dummyUns, &dummyUns);
  240.         XSetErrorHandler(NULL);
  241.  
  242.     if ((status != 0) && (w != XtWindow(dispPtr->commWidget))) {
  243.         Tcl_AppendResult(interp, "interpreter name \"", name,
  244.             "\" is already in use", (char *) NULL);
  245.         XUngrabServer(dispPtr->display);
  246.         XFlush(dispPtr->display);
  247.         return TCL_ERROR;
  248.     } 
  249.     (void) LookupName(dispPtr, name, 1);
  250.     }
  251.     sprintf(propInfo, "%x %.*s", XtWindow(dispPtr->commWidget),
  252.         TCL_MAX_NAME_LENGTH, name);
  253.     XChangeProperty(dispPtr->display,
  254.         RootWindow(dispPtr->display, 0),
  255.         dispPtr->registryProperty, XA_STRING, 8, PropModeAppend,
  256.         (unsigned char *) propInfo, strlen(propInfo)+1);
  257.     XUngrabServer(dispPtr->display);
  258.     XFlush(dispPtr->display);
  259.  
  260.     /*
  261.      * Add an entry in the local registry of names owned by this
  262.      * process.
  263.      */
  264.  
  265.     riPtr = (RegisteredInterp *) XtMalloc(sizeof(RegisteredInterp));
  266.     riPtr->name = (char *) XtMalloc((unsigned) (strlen(name) + 1));
  267.     strcpy(riPtr->name, name);
  268.     riPtr->interp = interp;
  269.     riPtr->dispPtr = dispPtr;
  270.     riPtr->nextPtr = registry;
  271.     registry = riPtr;
  272.  
  273.     /*
  274.      * Add the "send" command to this interpreter, and arrange for
  275.      * us to be notified when the interpreter is deleted (actually,
  276.      * when the "send" command is deleted).
  277.      */
  278.  
  279.     Tcl_CreateCommand(interp, "send", Tm_SendCmd, (ClientData) riPtr,
  280.         DeleteProc);
  281.  
  282.     return TCL_OK;
  283. }
  284.  
  285. void SendRestrictEvents(app, w, pending)
  286.     XtAppContext app;
  287.     Widget w;
  288.     PendingCommand *pending;
  289. {
  290.     XEvent event;
  291.  
  292.     while (pending->result == NULL) {
  293.     if (XtAppPeekEvent(app, &event)) {
  294.         if (event.type == PropertyNotify &&
  295.             event.xproperty.window == XtWindow(w) &&
  296.             event.xproperty.display == XtDisplay(w)) {
  297.          XtAppProcessEvent(app, XtIMAll);
  298.         }
  299.     }
  300.     }
  301. }
  302. /*
  303.  *--------------------------------------------------------------
  304.  *
  305.  * Tm_SendCmd --
  306.  *
  307.  *    This procedure is invoked to process the "send" Tcl command.
  308.  *    See the user documentation for details on what it does.
  309.  *
  310.  * Results:
  311.  *    A standard Tcl result.
  312.  *
  313.  * Side effects:
  314.  *    See the user documentation.
  315.  *
  316.  *--------------------------------------------------------------
  317.  */
  318.  
  319. int
  320. Tm_SendCmd(clientData, interp, argc, argv)
  321.     ClientData clientData;        /* Information about sender (only
  322.                      * dispPtr field is used). */
  323.     Tcl_Interp *interp;            /* Current interpreter. */
  324.     int argc;                /* Number of arguments. */
  325.     char **argv;            /* Argument strings. */
  326. {
  327.     RegisteredInterp *senderRiPtr = (RegisteredInterp *) clientData;
  328.     Window w;
  329. #define STATIC_PROP_SPACE 100
  330.     char *property, staticSpace[STATIC_PROP_SPACE];
  331.     int length;
  332.     static int serial = 0;    /* Running count of sent commands.
  333.                  * Used to give each command a
  334.                  * different serial number. */
  335.     PendingCommand pending;
  336.     XtIntervalId timer;
  337.     XtAppContext app;
  338.     register RegisteredInterp *riPtr;
  339.     char *cmd;
  340.     int result;
  341.     Bool (*prevRestrictProc)();
  342.     char *prevArg;
  343.     Tm_Display *dispPtr = senderRiPtr->dispPtr;
  344.  
  345.     if (dispPtr->commWidget == NULL) {
  346.     result = SendInit(interp, dispPtr);
  347.     if (result != TCL_OK) {
  348.         return result;
  349.     }
  350.     }
  351.  
  352.     if (argc < 3) {
  353.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  354.         " interpName arg ?arg ...?\"", (char *) NULL);
  355.     return TCL_ERROR;
  356.     }
  357.     if (argc == 3) {
  358.     cmd = argv[2];
  359.     } else {
  360.     cmd = Tcl_Concat(argc-2, argv+2);
  361.     }
  362.  
  363.     /*
  364.      * See if the target interpreter is local.  If so, execute
  365.      * the command directly without going through the X server.
  366.      * The only tricky thing is passing the result from the target
  367.      * interpreter to the invoking interpreter.  Watch out:  they
  368.      * could be the same!
  369.      */
  370.  
  371.     for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) {
  372.     if (strcmp(riPtr->name, argv[1]) != 0) {
  373.         continue;
  374.     }
  375.     if (interp == riPtr->interp) {
  376.         result = Tcl_GlobalEval(interp, cmd);
  377.     } else {
  378.         result = Tcl_GlobalEval(riPtr->interp, cmd);
  379.         interp->result = riPtr->interp->result;
  380.         interp->freeProc = riPtr->interp->freeProc;
  381.         riPtr->interp->freeProc = 0;
  382.         Tcl_ResetResult(riPtr->interp);
  383.     }
  384.     if (cmd != argv[2]) {
  385.         ckfree(cmd);
  386.     }
  387.     return result;
  388.     }
  389.  
  390.     /*
  391.      * Bind the interpreter name to a communication window.
  392.      */
  393.  
  394.     w = LookupName(dispPtr, argv[1], 0);
  395.     if (w == 0) {
  396.     Tcl_AppendResult(interp, "no registered interpeter named \"",
  397.         argv[1], "\"", (char *) NULL);
  398.     if (cmd != argv[2]) {
  399.         ckfree(cmd);
  400.     }
  401.     return TCL_ERROR;
  402.     }
  403.  
  404.     /*
  405.      * Register the fact that we're waiting for a command to
  406.      * complete (this is needed by SendEventProc and by
  407.      * AppendErrorProc to pass back the command's results).
  408.      */
  409.  
  410.     serial++;
  411.     pending.serial = serial;
  412.     pending.target = argv[1];
  413.     pending.interp = interp;
  414.     pending.result = NULL;
  415.     pending.timedOut = FALSE;
  416.     pending.nextPtr = pendingCommands;
  417.     pendingCommands = &pending;
  418.  
  419.     /*
  420.      * Send the command to target interpreter by appending it to the
  421.      * comm window in the communication window.
  422.      */
  423.  
  424.     length = strlen(argv[1]) + strlen(cmd) + 30;
  425.     if (length <= STATIC_PROP_SPACE) {
  426.     property = staticSpace;
  427.     } else {
  428.     property = (char *) XtMalloc((unsigned) length);
  429.     }
  430.     sprintf(property, "C %x %x %s|%s",
  431.         XtWindow(dispPtr->commWidget), serial, argv[1], cmd);
  432.     (void) AppendPropCarefully(dispPtr->display, w, dispPtr->commProperty,
  433.         property, &pending);
  434.     if (length > STATIC_PROP_SPACE) {
  435.     ckfree(property);
  436.     }
  437.     if (cmd != argv[2]) {
  438.     ckfree(cmd);
  439.     }
  440.  
  441.     /*
  442.      * Enter a loop processing X events until the result comes
  443.      * in.  If no response is received within a few seconds,
  444.      * then timeout.  While waiting for a result, look only at
  445.      * send-related events (otherwise it would be possible for
  446.      * additional input events, such as mouse motion, to cause
  447.      * other sends, leading eventually to such a large number
  448.      * of nested Tcl_Eval calls that the Tcl interpreter panics).
  449.      */
  450.  
  451. /*
  452.     prevRestrictProc = Tm_RestrictEvents(SendRestrictProc,
  453.         (char *) dispPtr->commWidget, &prevArg);
  454.     timeout = Tm_CreateTimerHandler(5000, TimeoutProc,
  455.         (ClientData) &pending);
  456.     while (pending.result == NULL) {
  457.     Tm_DoOneEvent(0);
  458.     }
  459.     Tm_DeleteTimerHandler(timeout);
  460.     (void) Tm_RestrictEvents(prevRestrictProc, prevArg, &prevArg);
  461. */
  462.     app = XtWidgetToApplicationContext(dispPtr->commWidget);
  463.     timer = XtAppAddTimeOut(app, 5000, TimeoutProc, (XtPointer) &pending);
  464.  
  465.     SendRestrictEvents(app, dispPtr->commWidget, &pending);
  466.  
  467.     if ( ! pending.timedOut) {
  468.     XtRemoveTimeOut(timer);
  469.     }
  470.  
  471.     /*
  472.      * Unregister the information about the pending command
  473.      * and return the result.
  474.      */
  475.  
  476.     if (pendingCommands == &pending) {
  477.     pendingCommands = pending.nextPtr;
  478.     } else {
  479.     PendingCommand *pcPtr;
  480.  
  481.     for (pcPtr = pendingCommands; pcPtr != NULL;
  482.         pcPtr = pcPtr->nextPtr) {
  483.         if (pcPtr->nextPtr == &pending) {
  484.         pcPtr->nextPtr = pending.nextPtr;
  485.         break;
  486.         }
  487.     }
  488.     }
  489.     Tcl_SetResult(interp, pending.result, TCL_DYNAMIC);
  490.     return pending.code;
  491. }
  492.  
  493. /*
  494.  *----------------------------------------------------------------------
  495.  *
  496.  * TkGetInterpNames --
  497.  *
  498.  *    This procedure is invoked to fetch a list of all the
  499.  *    interpreter names currently registered for the display
  500.  *    of a particular window.
  501.  *
  502.  * Results:
  503.  *    A standard Tcl return value.  Interp->result will be set
  504.  *    to hold a list of all the interpreter names defined for
  505.  *    tkwin's display.  If an error occurs, then TCL_ERROR
  506.  *    is returned and interp->result will hold an error message.
  507.  *
  508.  * Side effects:
  509.  *    None.
  510.  *
  511.  *----------------------------------------------------------------------
  512.  */
  513.  
  514. int
  515. TkGetInterpNames(interp, dispPtr)
  516.     Tcl_Interp *interp;        /* Interpreter for returning a result. */
  517.     Tm_Display *dispPtr;        /* Window whose display is to be used
  518.                  * for the lookup. */
  519. {
  520.     char *regProp, *separator, *name;
  521.     register char *p;
  522.     int result, actualFormat;
  523.     unsigned long numItems, bytesAfter;
  524.     Atom actualType;
  525.  
  526.     /*
  527.      * Read the registry property.
  528.      */
  529.  
  530.     regProp = NULL;
  531.     result = XGetWindowProperty(dispPtr->display,
  532.         RootWindow(dispPtr->display, 0),
  533.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  534.         False, XA_STRING, &actualType, &actualFormat,
  535.         &numItems, &bytesAfter, (unsigned char **) ®Prop);
  536.  
  537.     if (actualType == None) {
  538.     sprintf(interp->result, "couldn't read intepreter registry property");
  539.     return TCL_ERROR;
  540.     }
  541.  
  542.     /*
  543.      * If the property is improperly formed, then delete it.
  544.      */
  545.  
  546.     if ((result != Success) || (actualFormat != 8)
  547.         || (actualType != XA_STRING)) {
  548.     if (regProp != NULL) {
  549.         XFree(regProp);
  550.     }
  551.     sprintf(interp->result, "intepreter registry property is badly formed");
  552.     return TCL_ERROR;
  553.     }
  554.  
  555.     /*
  556.      * Scan all of the names out of the property.
  557.      */
  558.  
  559.     separator = "";
  560.     for (p = regProp; (p-regProp) < numItems; p++) {
  561.     name = p;
  562.     while ((*p != 0) && (!isspace(*p))) {
  563.         p++;
  564.     }
  565.     if (*p != 0) {
  566.         name = p+1;
  567.         name = Tcl_Merge(1, &name);
  568.         Tcl_AppendResult(interp, separator, name, (char *) NULL);
  569.         while (*p != 0) {
  570.         p++;
  571.         }
  572.         separator = " ";
  573.     }
  574.     }
  575.     XFree(regProp);
  576.     return TCL_OK;
  577. }
  578.  
  579. /*
  580.  *--------------------------------------------------------------
  581.  *
  582.  * SendInit --
  583.  *
  584.  *    This procedure is called to initialize the
  585.  *    communication channels for sending commands and
  586.  *    receiving results.
  587.  *
  588.  * Results:
  589.  *    The result is a standard Tcl return value, which is
  590.  *    normally TCL_OK.  If an error occurs then an error
  591.  *    message is left in interp->result and TCL_ERROR is
  592.  *    returned.
  593.  *
  594.  * Side effects:
  595.  *    Sets up various data structures and windows.
  596.  *
  597.  *--------------------------------------------------------------
  598.  */
  599.  
  600. static int
  601. SendInit(interp, dispPtr)
  602.     Tcl_Interp *interp;        /* Interpreter to use for error
  603.                  * reporting. */
  604.     register Tm_Display *dispPtr;/* Display to initialize. */
  605.  
  606. {
  607.     XSetWindowAttributes atts;
  608.     Tcl_CmdInfo cmdInfo;
  609.     Widget parent;
  610.  
  611.     /*
  612.      * Create the window used for communication, and set up an
  613.      * event handler for it.
  614.      */
  615.  
  616. /*
  617.     dispPtr->commWidget = Tm_CreateWindow(interp, (Tk_Window) NULL,
  618.         "_comm", DisplayString(dispPtr->display));
  619. */
  620.     Tcl_GetCommandInfo(interp, ".", &cmdInfo);
  621.     parent = ((Tm_Widget *) cmdInfo.clientData)->displayInfo->toplevel;
  622.     dispPtr->commWidget = XtVaCreateWidget("_comm",
  623.                     transientShellWidgetClass,
  624.                     parent,
  625.                                         XtNgeometry, "10x10",
  626.                                         XtNoverrideRedirect, TRUE,
  627.                     NULL);
  628.  
  629.     if (dispPtr->commWidget == NULL) {
  630.     return TCL_ERROR;
  631.     }
  632.     XtRealizeWidget(dispPtr->commWidget);
  633. /*
  634.     atts.override_redirect = True;
  635.     Tm_ChangeWindowAttributes(dispPtr->commWidget,
  636.         CWOverrideRedirect, &atts);
  637.     Tm_CreateEventHandler(dispPtr->commWidget, PropertyChangeMask,
  638.         SendEventProc, (ClientData) dispPtr);
  639.     Tm_MakeWindowExist(dispPtr->commWidget);
  640. */
  641.     XtAddEventHandler(dispPtr->commWidget, PropertyChangeMask,
  642.             FALSE, SendEventProc, (XtPointer) dispPtr);
  643.  
  644.     /*
  645.      * Get atoms used as property names.
  646.      */
  647.  
  648.     dispPtr->commProperty = XInternAtom(dispPtr->display,
  649.         "Comm", False);
  650.     dispPtr->registryProperty = XInternAtom(dispPtr->display,
  651.         "InterpRegistry", False);
  652.     return TCL_OK;
  653. }
  654.  
  655. /*
  656.  *--------------------------------------------------------------
  657.  *
  658.  * LookupName --
  659.  *
  660.  *    Given an interpreter name, see if the name exists in
  661.  *    the interpreter registry for a particular display.
  662.  *
  663.  * Results:
  664.  *    If the given name is registered, return the ID of
  665.  *    the window associated with the name.  If the name
  666.  *    isn't registered, then return 0.
  667.  *
  668.  * Side effects:
  669.  *    If the registry property is improperly formed, then
  670.  *    it is deleted.  If "delete" is non-zero, then if the
  671.  *    named interpreter is found it is removed from the
  672.  *    registry property.
  673.  *
  674.  *--------------------------------------------------------------
  675.  */
  676.  
  677. static Window
  678. LookupName(dispPtr, name, delete)
  679.     register Tm_Display *dispPtr;
  680.             /* Display whose registry to check. */
  681.     char *name;        /* Name of an interpreter. */
  682.     int delete;        /* If non-zero, delete info about name. */
  683. {
  684.     char *regProp, *entry;
  685.     register char *p;
  686.     int result, actualFormat;
  687.     unsigned long numItems, bytesAfter;
  688.     Atom actualType;
  689.     Window returnValue;
  690.  
  691.     /*
  692.      * Read the registry property.
  693.      */
  694.  
  695.     regProp = NULL;
  696.     result = XGetWindowProperty(dispPtr->display,
  697.         RootWindow(dispPtr->display, 0),
  698.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  699.         False, XA_STRING, &actualType, &actualFormat,
  700.         &numItems, &bytesAfter, (unsigned char **) ®Prop);
  701.  
  702.     if (actualType == None) {
  703.     return 0;
  704.     }
  705.  
  706.     /*
  707.      * If the property is improperly formed, then delete it.
  708.      */
  709.  
  710.     if ((result != Success) || (actualFormat != 8)
  711.         || (actualType != XA_STRING)) {
  712.     if (regProp != NULL) {
  713.         XFree(regProp);
  714.     }
  715.     XDeleteProperty(dispPtr->display,
  716.         RootWindow(dispPtr->display, 0),
  717.         dispPtr->registryProperty);
  718.     return 0;
  719.     }
  720.  
  721.     /*
  722.      * Scan the property for the desired name.
  723.      */
  724.  
  725.     returnValue = (Window) 0;
  726.     entry = NULL;    /* Not needed, but eliminates compiler warning. */
  727.     for (p = regProp; (p-regProp) < numItems; ) {
  728.     entry = p;
  729.     while ((*p != 0) && (!isspace(*p))) {
  730.         p++;
  731.     }
  732.     if ((*p != 0) && (strcmp(name, p+1) == 0)) {
  733.         sscanf(entry, "%x", &returnValue);
  734.         break;
  735.     }
  736.     while (*p != 0) {
  737.         p++;
  738.     }
  739.     p++;
  740.     }
  741.  
  742.     /*
  743.      * Delete the property, if that is desired (copy down the
  744.      * remainder of the registry property to overlay the deleted
  745.      * info, then rewrite the property).
  746.      */
  747.  
  748.     if ((delete) && (returnValue != 0)) {
  749.     int count;
  750.  
  751.     while (*p != 0) {
  752.         p++;
  753.     }
  754.     p++;
  755.     count = numItems - (p-regProp);
  756.     if (count > 0) {
  757.         memcpy((VOID *) entry, (VOID *) p, count);
  758.     }
  759.     XChangeProperty(dispPtr->display,
  760.         RootWindow(dispPtr->display, 0),
  761.         dispPtr->registryProperty, XA_STRING, 8,
  762.         PropModeReplace, (unsigned char *) regProp,
  763.         (int) (numItems - (p-entry)));
  764.     XSync(dispPtr->display, False);
  765.     }
  766.  
  767.     XFree(regProp);
  768.     return returnValue;
  769. }
  770.  
  771. /*
  772.  *--------------------------------------------------------------
  773.  *
  774.  * SendEventProc --
  775.  *
  776.  *    This procedure is invoked automatically by the toolkit
  777.  *    event manager when a property changes on the communication
  778.  *    window.  This procedure reads the property and handles
  779.  *    command requests and responses.
  780.  *
  781.  * Results:
  782.  *    None.
  783.  *
  784.  * Side effects:
  785.  *    If there are command requests in the property, they
  786.  *    are executed.  If there are responses in the property,
  787.  *    their information is saved for the (ostensibly waiting)
  788.  *    "send" commands. The property is deleted.
  789.  *
  790.  *--------------------------------------------------------------
  791.  */
  792.  
  793. static void
  794. SendEventProc(w, clientData, eventPtr, continue_dispatch)
  795.     Widget w;
  796.     XtPointer clientData;    /* Display information. */    
  797.     XEvent *eventPtr;        /* Information about event. */
  798.     Boolean *continue_dispatch;
  799. {
  800.     Tm_Display *dispPtr = (Tm_Display *) clientData;
  801.     char *propInfo;
  802.     register char *p;
  803.     int result, actualFormat;
  804.     unsigned long numItems, bytesAfter;
  805.     Atom actualType;
  806.  
  807.     if ((eventPtr->xproperty.atom != dispPtr->commProperty)
  808.         || (eventPtr->xproperty.state != PropertyNewValue)) {
  809.     return;
  810.     }
  811.  
  812.     /*
  813.      * Read the comm property and delete it.
  814.      */
  815.  
  816.     propInfo = NULL;
  817.     XSetErrorHandler(NoOpProc);
  818.     result = XGetWindowProperty(dispPtr->display,
  819.         XtWindow(dispPtr->commWidget),
  820.         dispPtr->commProperty, 0, MAX_PROP_WORDS, True,
  821.         XA_STRING, &actualType, &actualFormat,
  822.         &numItems, &bytesAfter, (unsigned char **) &propInfo);
  823.     XSetErrorHandler(NULL);
  824.  
  825.     /*
  826.      * If the property doesn't exist or is improperly formed
  827.      * then ignore it.
  828.      */
  829.  
  830.     if ((result != Success) || (actualType != XA_STRING)
  831.         || (actualFormat != 8)) {
  832.     if (propInfo != NULL) {
  833.         XFree(propInfo);
  834.     }
  835.     return;
  836.     }
  837.  
  838.     /*
  839.      * The property is divided into records separated by null
  840.      * characters.  Each record represents one command request
  841.      * or response.  Scan through the property one record at a
  842.      * time.
  843.      */
  844.  
  845.     for (p = propInfo; (p-propInfo) < numItems; ) {
  846.     if (*p == 'C') {
  847.         Window window;
  848.         int serial, resultSize;
  849.         char *resultString, *interpName, *returnProp, *end;
  850.         register RegisteredInterp *riPtr;
  851.         char errorMsg[100];
  852. #define STATIC_RESULT_SPACE 100
  853.         char staticSpace[STATIC_RESULT_SPACE];
  854.  
  855.         /*
  856.          *-----------------------------------------------------
  857.          * This is an incoming command sent by another window.
  858.          * Parse the fields of the command string.  If the command
  859.          * string isn't properly formed, send back an error message
  860.          * if there's enough well-formed information to generate
  861.          * a proper reply;  otherwise just ignore the message.
  862.          *-----------------------------------------------------
  863.          */
  864.  
  865.         p++;
  866.         window = (Window) strtol(p, &end, 16);
  867.         if (end == p) {
  868.         goto nextRecord;
  869.         }
  870.         p = end;
  871.         if (*p != ' ') {
  872.         goto nextRecord;
  873.         }
  874.         p++;
  875.         serial = strtol(p, &end, 16);
  876.         if (end == p) {
  877.         goto nextRecord;
  878.         }
  879.         p = end;
  880.         if (*p != ' ') {
  881.         goto nextRecord;
  882.         }
  883.         p++;
  884.         interpName = p;
  885.         while ((*p != 0) && (*p != '|')) {
  886.         p++;
  887.         }
  888.         if (*p != '|') {
  889.         result = TCL_ERROR;
  890.         resultString = "bad property format for sent command";
  891.         goto returnResult;
  892.         }
  893.         *p = 0;
  894.         p++;
  895.  
  896.         /*
  897.          * Locate the interpreter for the command, then
  898.          * execute the command.
  899.          */
  900.  
  901.         for (riPtr = registry; ; riPtr = riPtr->nextPtr) {
  902.         if (riPtr == NULL) {
  903.             result = TCL_ERROR;
  904.             sprintf(errorMsg,
  905.                 "receiver never heard of interpreter \"%.40s\"",
  906.                 interpName);
  907.             resultString = errorMsg;
  908.             goto returnResult;
  909.         }
  910.         if (strcmp(riPtr->name, interpName) == 0) {
  911.             break;
  912.         }
  913.         }
  914.         result = Tcl_GlobalEval(riPtr->interp, p);
  915.         resultString = riPtr->interp->result;
  916.  
  917.         /*
  918.          * Return the result to the sender.
  919.          */
  920.  
  921.         returnResult:
  922.         resultSize = strlen(resultString) + 30;
  923.         if (resultSize <= STATIC_RESULT_SPACE) {
  924.         returnProp = staticSpace;
  925.         } else {
  926.         returnProp = (char *) XtMalloc((unsigned) resultSize);
  927.         }
  928.         sprintf(returnProp, "R %x %d %s", serial, result,
  929.             resultString);
  930.         (void) AppendPropCarefully(dispPtr->display, window,
  931.             dispPtr->commProperty, returnProp,
  932.             (PendingCommand *) NULL);
  933.         if (returnProp != staticSpace) {
  934.         ckfree(returnProp);
  935.         }
  936.     } else if (*p == 'R') {
  937.         int serial, code;
  938.         char *end;
  939.         register PendingCommand *pcPtr;
  940.  
  941.         /*
  942.          *-----------------------------------------------------
  943.          * This record in the property is a result being
  944.          * returned for a command sent from here.  First
  945.          * parse the fields.
  946.          *-----------------------------------------------------
  947.          */
  948.  
  949.         p++;
  950.         serial = strtol(p, &end, 16);
  951.         if (end == p) {
  952.         goto nextRecord;
  953.         }
  954.         p = end;
  955.         if (*p != ' ') {
  956.         goto nextRecord;
  957.         }
  958.         p++;
  959.         code = strtol(p, &end, 10);
  960.         if (end == p) {
  961.         goto nextRecord;
  962.         }
  963.         p = end;
  964.         if (*p != ' ') {
  965.         goto nextRecord;
  966.         }
  967.         p++;
  968.  
  969.         /*
  970.          * Give the result information to anyone who's
  971.          * waiting for it.
  972.          */
  973.  
  974.         for (pcPtr = pendingCommands; pcPtr != NULL;
  975.             pcPtr = pcPtr->nextPtr) {
  976.         if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) {
  977.             continue;
  978.         }
  979.         pcPtr->code = code;
  980.         pcPtr->result = XtMalloc((unsigned) (strlen(p) + 1));
  981.         strcpy(pcPtr->result, p);
  982.         break;
  983.         }
  984.     }
  985.  
  986.     nextRecord:
  987.     while (*p != 0) {
  988.         p++;
  989.     }
  990.     p++;
  991.     }
  992.     XFree(propInfo);
  993. }
  994.  
  995. static PendingCommand *globalPendingPtr; /* hack for poor error handling */
  996. /*
  997.  *--------------------------------------------------------------
  998.  *
  999.  * AppendPropCarefully --
  1000.  *
  1001.  *    Append a given property to a given window, but set up
  1002.  *    an X error handler so that if the append fails this
  1003.  *    procedure can return an error code rather than having
  1004.  *    Xlib panic.
  1005.  *
  1006.  * Results:
  1007.  *    None.
  1008.  *
  1009.  * Side effects:
  1010.  *    The given property on the given window is appended to.
  1011.  *    If this operation fails and if pendingPtr is non-NULL,
  1012.  *    then the pending operation is marked as complete with
  1013.  *    an error.
  1014.  *
  1015.  *--------------------------------------------------------------
  1016.  */
  1017.  
  1018. static void
  1019. AppendPropCarefully(display, window, property, value, pendingPtr)
  1020.     Display *display;        /* Display on which to operate. */
  1021.     Window window;        /* Window whose property is to
  1022.                  * be modified. */
  1023.     Atom property;        /* Name of property. */
  1024.     char *value;        /* Characters (null-terminated) to
  1025.                  * append to property. */
  1026.     PendingCommand *pendingPtr;    /* Pending command to mark complete
  1027.                  * if an error occurs during the
  1028.                  * property op.  NULL means just
  1029.                  * ignore the error. */
  1030. {
  1031.     /* I don't have a full error mechanism going that forms lists
  1032.      * with client_data like Tk does, so I'll indulge in a grotty
  1033.      * piece of code: set a global to hold the PendingCommand and
  1034.      * XSync to force execution of the error handler before anything
  1035.      * else happens. One day, clean this up
  1036.      */
  1037.     XSetErrorHandler(AppendErrorProc);
  1038.     globalPendingPtr = pendingPtr;
  1039.     XChangeProperty(display, window, property, XA_STRING, 8,
  1040.         PropModeAppend, (unsigned char *) value, strlen(value)+1);
  1041.     XSync(display, False);
  1042.     XSetErrorHandler(NULL);
  1043. }
  1044.  
  1045. /*
  1046.  * The procedure below is invoked if an error occurs during
  1047.  * the XChangeProperty operation above.
  1048.  */
  1049.  
  1050.     /* ARGSUSED */
  1051. static int
  1052. AppendErrorProc(display, errorPtr)
  1053.     Display *display;
  1054.     XErrorEvent *errorPtr;    /* Information about error. */
  1055. {
  1056.     PendingCommand *pendingPtr = globalPendingPtr;
  1057.     register PendingCommand *pcPtr;
  1058.  
  1059.     if (pendingPtr == NULL) {
  1060.     return 0;
  1061.     }
  1062.  
  1063.     /*
  1064.      * Make sure this command is still pending.
  1065.      */
  1066.  
  1067.     for (pcPtr = pendingCommands; pcPtr != NULL;
  1068.         pcPtr = pcPtr->nextPtr) {
  1069.     if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) {
  1070.         pcPtr->result = XtMalloc((unsigned) (strlen(pcPtr->target) + 50));
  1071.         sprintf(pcPtr->result,
  1072.             "send to \"%s\" failed (no communication window)",
  1073.             pcPtr->target);
  1074.         pcPtr->code = TCL_ERROR;
  1075.         break;
  1076.     }
  1077.     }
  1078.     return 0;
  1079. }
  1080.  
  1081. /*
  1082.  *--------------------------------------------------------------
  1083.  *
  1084.  * TimeoutProc --
  1085.  *
  1086.  *    This procedure is invoked when too much time has elapsed
  1087.  *    during the processing of a sent command.
  1088.  *
  1089.  * Results:
  1090.  *    None.
  1091.  *
  1092.  * Side effects:
  1093.  *    Mark the pending command as complete, with an error
  1094.  *    message signalling the timeout.
  1095.  *
  1096.  *--------------------------------------------------------------
  1097.  */
  1098.  
  1099. static void
  1100. TimeoutProc(clientData, timer)
  1101.     XtPointer clientData;    /* Information about command that
  1102.                  * has been sent but not yet
  1103.                  * responded to. */
  1104.     XtIntervalId *timer;
  1105. {
  1106.     PendingCommand *pcPtr = (PendingCommand *) clientData;
  1107.     register PendingCommand *pcPtr2;
  1108.  
  1109.     /*
  1110.      * Make sure that the command is still in the pending list
  1111.      * and that it hasn't already completed.  Then register the
  1112.      * error.
  1113.      */
  1114.  
  1115.     for (pcPtr2 = pendingCommands; pcPtr2 != NULL;
  1116.         pcPtr2 = pcPtr2->nextPtr) {
  1117.     static char msg[] = "remote interpreter did not respond";
  1118.     if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) {
  1119.         continue;
  1120.     }
  1121.     pcPtr2->code = TCL_ERROR;
  1122.     pcPtr2->result = XtMalloc((unsigned) (sizeof(msg) + 1));
  1123.     strcpy(pcPtr2->result, msg);
  1124.     pcPtr2->timedOut = TRUE;
  1125.     return;
  1126.     }
  1127. }
  1128.  
  1129. /*
  1130.  *--------------------------------------------------------------
  1131.  *
  1132.  * DeleteProc --
  1133.  *
  1134.  *    This procedure is invoked by Tcl when a registered
  1135.  *    interpreter is about to be deleted.  It unregisters
  1136.  *    the interpreter.
  1137.  *
  1138.  * Results:
  1139.  *    None.
  1140.  *
  1141.  * Side effects:
  1142.  *    The interpreter given by riPtr is unregistered.
  1143.  *
  1144.  *--------------------------------------------------------------
  1145.  */
  1146.  
  1147. static void
  1148. DeleteProc(clientData)
  1149.     ClientData clientData;    /* Info about registration, passed
  1150.                  * as ClientData. */
  1151. {
  1152.     RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
  1153.     register RegisteredInterp *riPtr2;
  1154.  
  1155.     XGrabServer(riPtr->dispPtr->display);
  1156.     (void) LookupName(riPtr->dispPtr, riPtr->name, 1);
  1157.     XUngrabServer(riPtr->dispPtr->display);
  1158.     XFlush(riPtr->dispPtr->display);
  1159.     if (registry == riPtr) {
  1160.     registry = riPtr->nextPtr;
  1161.     } else {
  1162.     for (riPtr2 = registry; riPtr2 != NULL;
  1163.         riPtr2 = riPtr2->nextPtr) {
  1164.         if (riPtr2->nextPtr == riPtr) {
  1165.         riPtr2->nextPtr = riPtr->nextPtr;
  1166.         break;
  1167.         }
  1168.     }
  1169.     }
  1170.     ckfree((char *) riPtr->name);
  1171.     ckfree((char *) riPtr);
  1172. }
  1173.  
  1174. /*
  1175.  *----------------------------------------------------------------------
  1176.  *
  1177.  * SendRestrictProc --
  1178.  *
  1179.  *    This procedure filters incoming events when a "send" command
  1180.  *    is outstanding.  It defers all events except those containing
  1181.  *    send commands and results.
  1182.  *
  1183.  * Results:
  1184.  *    False is returned except for property-change events on the
  1185.  *    given commWidget.
  1186.  *
  1187.  * Side effects:
  1188.  *    None.
  1189.  *
  1190.  *----------------------------------------------------------------------
  1191.  */
  1192.  
  1193.     /* ARGSUSED */
  1194. /*
  1195. static Bool
  1196. SendRestrictProc(display, eventPtr, arg)
  1197.     Display *display;
  1198.     register XEvent *eventPtr;
  1199.     char *arg;        
  1200. {
  1201.     register Tm_Window comm = (Tk_Window) arg;
  1202.  
  1203.     if ((display != Tm_Display(comm))
  1204.         || (eventPtr->type != PropertyNotify)
  1205.         || (eventPtr->xproperty.window != Tm_WindowId(comm))) {
  1206.     return False;
  1207.     }
  1208.     return True;
  1209. }
  1210. */
  1211.